Shareware Grab Bag/Shareware Grab Bag.iso/008/egagraph.arc/BOXDEMO.PAS

Pascal/Delphi Source File | 1987-07-23 | 19.6 KB | 669 lines

program BoxDemo;

(* ================================================= *)
(* =  This program demonstraits the fast EGA line  = *)
(* =  drawing routine. The program has other GOOD  = *)
(* =  stuff in it..so use  what you can..any  way  = *)
(* =  you  can..at  you  own  expense..good  luck  = *)
(* =  graphicsing.                                 = *)
(* =                                               = *)
(* =  James Billmeyer                              = *)
(* =  Soft-Touch Computer Systems                  = *)
(* =  7716 Balboa Blvd., Unit D                    = *)
(* =  Van Nuys, Ca. 91406                          = *)
(* =  [phone]                               = *)
(* ================================================= *)


const
   middle_horizontal  = 320;
   middle_vertical    = 175;

   horizontal_scale   = 1.53241;
   vertical_scale     = 1.0000;
   longitudinal_scale =  0.5005657;

(*   ===================================== *)

type
   cgtype = string[3];
   str10  = string[10];

   border_type     = (DB,NB);
   projection_type = (PARALLEL,PERSPECTIVE);
   model_type      = (LARGE,SMALL);

   line_info = record
                  x1,
                  y1,
                  x2,
                  y2,
                  color :  integer;
               end;


   object_lines = array[1..9] of line_info;


   coord_type = record
                   x,
                   y,
                   z :  real;
                end;

   object_info = record
                    name                :  string[10];
                    number_of_surface   :  integer;
                    number_of_lines     :  integer;
                    old_number_of_lines :  integer;
                    surface_to_view     :  string[48];
                    lines_to_view       :  string[24];
                    vertex              :  array[1..4] of coord_type;
                    lines               :  object_lines;
                    old_lines           :  object_lines;
                    coord_reset         :  integer;
                    coordinates,
                    end_coordinates     :  coord_type;
                    otheta,
                    ophi,
                    obeta               :  real;
                 end;

   trig_type = record
                  sin0,
                  cos0,
                  sin1,
                  cos1,
                  sin2,
                  cos2 : real;
               end;


var
   projection  : projection_type;
   line        : line_info;
   test,
   oldtest     : object_info;
   trig_set    : trig_type;
   model       : model_type;

   xdir,ydir,i,j,
   tx,ty,tz,
   color,
   loop,
   xscrn,yscrn,
   xscrn0,yscrn0,
   total_surfaces,
   wxmin,wymin,wxmax,wymax : integer;

   ok,
   dir,firstime  :  boolean;

   dist,
   xwrld,ywrld,zwrld,
   theta,beta,phi,
   x_scale,y_scale,z_scale : real;


procedure drawline(x1,y1,x2,y2,color : integer); External 'LINE.BIN';

procedure get_object_from_file(var object: object_info; object_name: str10);

(* ================================================ *)
(* =  The get_object_from_file  procedure  loads  = *)
(* =  object information into the arrays.         = *)
(* ================================================ *)

begin
   with  object  do
      begin
         name := 'Test';
         number_of_surface := 3;
         lines_to_view   := '123847561328457614352786';
         surface_to_view := '011103090510070901060205021204100612081103080407';
         coordinates.x := 0.00;
         coordinates.y := 0.00;
         coordinates.z := 0.00;
         end_coordinates.x := 0.00;
         end_coordinates.y := 0.00;
         end_coordinates.z := 0.00;
         ophi   := 0.00;
         obeta  := 0.00;
         otheta := 0.00;
         vertex[1].x := -12.00;
         vertex[1].y := -12.00;
         vertex[2].x :=  12.00;
         vertex[2].y := -12.00;
         vertex[3].x := -12.00;
         vertex[3].y := -12.00;
         vertex[4].x := -12.00;
         vertex[4].y :=  12.00;
         vertex[4].z :=  12.00;
         vertex[1].z :=  12.00;
         vertex[2].z :=  12.00;
         vertex[3].z := -12.00;
      end;
end; (* proc Array_load *)


Procedure Phi_change(var trig_set: trig_type; dir: boolean);

(* ================================================ *)
(* =  The procedure Phi_change adds or subtracts  = *)
(* =  from the angle phi depending  on  the  dir  = *)
(* ================================================ *)

begin  (* proc Phi_change *)
   if  dir  then
      phi := phi + 0.04
   else
      phi := phi - 0.04;
   trig_set.sin0 := sin(phi);
   trig_set.cos0 := cos(phi);
end;  (* proc Phi_change *)


Procedure Beta_change(var trig_set: trig_type; dir: boolean);

(* ================================================ *)
(* =  The procedure Phi_change adds or subtracts  = *)
(* =  from the angle phi depending  on  the  dir  = *)
(* ================================================ *)

begin  (* proc beta_change *)
   if  dir  then
      beta := beta + 0.04
   else
      beta := beta - 0.04;
   trig_set.sin1 := sin(beta);
   trig_set.cos1 := cos(beta);
end;  (* proc beta_change *)


Procedure theta_change(var trig_set: trig_type; dir: boolean);

(* ================================================ *)
(* =  The procedure theta_change add or subtract  = *)
(* =  from the angle phi depending  on  the  dir  = *)
(* ================================================ *)

begin  (* proc theta_change *)
   if  dir  then
      theta := theta + 0.05
   else
      theta := theta - 0.05;
   trig_set.sin2 := sin(theta);
   trig_set.cos2 := cos(theta);
end;  (* proc theta_change *)


procedure Rotate(x,y,z: real; trig_set: trig_type; var xwrld,ywrld,zwrld: real);

(* ==================================== *)
(* =  This routine calculates the 3D  = *)
(* =  transformation matrix.          = *)
(* ==================================== *)

var
   group1,group2,group3 :  real;

begin
   with  trig_set  do
      begin
         group1 := -y * sin0 + z * cos0;
         group2 :=  y * cos0 + z * sin0;
         group3 :=  x * cos1 - group1 * sin1;
         xwrld :=  group3 * cos2 + group2 * sin2;
         ywrld :=  group2 * cos2 - group3 * sin2;
         zwrld :=  x * sin1 - group1 * cos1;
      end;
end;


Procedure Parallel_projection(var xscrn,yscrn: integer; xwrld,ywrld,zwrld: real);

(* ================================================ *)
(* =  Parallel_projection procedure converts      = *)
(* =  world coordinates to screen coordinates in  = *)
(* =  parallel projection.                        = *)
(* ================================================ *)

var
   ratio :  real;

begin  (* proc Parallel_projection *)
   xscrn := round(middle_horizontal + x_scale * xwrld);
   yscrn := round(middle_vertical   + y_scale * ywrld);
end;   (* proc Parallel_projection *)


procedure gwindow(xmin,ymin,xmax,ymax: integer; border: border_type);

(**************************************************)
(*  This procedure sets the  graphics window and  *)
(*  will draw the window border if directed.      *)
(*        DB => draw border                       *)
(*        NB => no border                         *)
(**************************************************)

begin
   wxmin := xmin + 1;
   wymin := ymin + 1;
   wxmax := xmax - 1;
   wymax := ymax - 1;
   if  border = DB  then
      begin
         drawline(xmin,ymin,xmax,ymin,1);
         drawline(xmin,ymax,xmax,ymax,1);
         drawline(xmax,ymin,xmax,ymax,1);
         drawline(xmin,ymin,xmin,ymax,1);
      end;
end;


procedure clipper(var x1,y1,x2,y2: integer);

(**************************************************)
(*  This  procedure  uses  the  Cohen-Sutherland  *)
(*  algorithm for line clipping.                  *)
(**************************************************)

type
   outcode = array[1..4] of boolean;

var
   accept,reject,done : boolean;
   outcode1,outcode2  : outcode;


   procedure outcodes(x,y: integer; var outcodeset: outcode);

   (**************************************************)
   (*  This procedure returns the  outcodes for the  *)
   (*  point (x,y)                                   *)
   (**************************************************)

   var
      i :  integer;

   begin
      for  i := 1  to  4  do
         outcodeset[i] := false;
      if  x < wxmin  then
         outcodeset[4] := true
      else if  x > wxmax  then
         outcodeset[3] := true;
      if  y > wymax  then
         outcodeset[2] := true
      else if  y < wymin  then
         outcodeset[1] := true;
   end;


   function reject_check(outcode1,outcode2: outcode): boolean;

   (**************************************************)
   (*  This function checks to see if the line lies  *)
   (*  outside the window.                           *)
   (**************************************************)

   var
      i      : integer;

   begin
      reject_check := false;
      for  i := 1  to  4  do
         if  (outcode1[i] and outcode2[i])  then
            begin
               reject_check := true;
               i := 4;
            end;
   end;


   function accept_check(outcode1,outcode2: outcode): boolean;

   (**************************************************)
   (*  This function checks to see if the line lies  *)
   (*  inside the window.                            *)
   (**************************************************)

   var
      i      : integer;

   begin
      accept_check := true;
      for  i := 1  to  4  do
         if  (outcode1[i] or outcode2[i])  then
            accept_check := false;
   end;


   procedure swap;

   (**************************************************)
   (*  This procedure swaps the point1  and  point2  *)
   (*  values.                                       *)
   (**************************************************)

   var
      pointemp    : integer;
      outcodetemp : outcode;

   begin
      pointemp := x1;
      x1 := x2;
      x2 := pointemp;
      pointemp := y1;
      y1 := y2;
      y2 := pointemp;
      outcodetemp := outcode1;
      outcode1 := outcode2;
      outcode2 := outcodetemp;
   end;


begin
   accept := false;
   reject := false;
   done   := false;
   outcodes(x1,y1,outcode1);
   outcodes(x2,y2,outcode2);
   repeat
      reject := reject_check(outcode1,outcode2);
      if  reject  then
         done := true
      else
         begin
            accept := accept_check(outcode1,outcode2);
            if  accept  then
               done := true
            else
               begin
                  if  not (outcode1[1] or outcode1[2] or outcode1[3] or outcode1[4])  then
                     swap;
                  if  outcode1[1]  then
                     begin
                        x1 := x1 + (x2 - x1) * (wymin - y1) div (y2 - y1);
                        y1 := wymin;
                     end
                  else if  outcode1[2]  then
                     begin
                        x1 := x1 + (x2 - x1) * (wymax - y1) div (y2 - y1);
                        y1 := wymax;
                     end
                  else if  outcode1[3]  then
                     begin
                        y1 := y1 + (y2 - y1) * (wxmax - x1) div (x2 - x1);
                        x1 := wxmax;
                     end
                  else if  outcode1[4]  then
                     begin
                        y1 := y1 + (y2 - y1) * (wxmin - x1) div (x2 - x1);
                        x1 := wxmin;
                     end
               end;
         end;
         if  not done  then
            outcodes(x1,y1,outcode1);
   until  done;
   if  reject  then
      begin
         x1 := wxmin;
         y1 := wymin;
         x2 := wxmin;
         y2 := wymin;
      end;
end;


Procedure calc_object_lines(var object: object_info);

(* ================================================ *)
(* =  The Draw_Scrn procedure draw an  object on  = *)
(* =  the screen.                                 = *)
(* ================================================ *)

const
   surface0  = $A0A;
   surface1  = $AC;
   surface2  = $CC0;
   surface3  = $505;
   surface4  = $53;
   surface5  = $330;
   line_loc : array[1..12] of integer = ($800,$400,$200,$100,$80,$40,$20,$10,$8,$4,$2,$1);
var
   x_wrld,
   y_wrld,
   z_wrld      :  array[1..8] of real;
   i,j,
   sindex,index,
   first,second,
   dummy,
   view_surface,
   line_count,
   lines_drawn,
   line_mask   :  integer;
   x,y,z,
   x_temp,
   y_temp,
   z_temp      :  real;

begin  (* proc calculate_lines *)
   for  i := 1  to  4  do
      with  object.vertex[i]  do
         begin
            if  model = SMALL  then
               z := 0;
            Rotate((x + object.coordinates.x),
                   (y + object.coordinates.y),
                   (z + object.coordinates.z),trig_set,xwrld,ywrld,zwrld);
            x_wrld[i] := xwrld;
            y_wrld[i] := ywrld;
            z_wrld[i] := zwrld;
         end;
   x_temp := x_wrld[2] - x_wrld[1];
   y_temp := y_wrld[2] - y_wrld[1];
   z_temp := z_wrld[2] - z_wrld[1];
   x_wrld[8] := x_temp + x_wrld[3];                  x_wrld[7] := x_temp + x_wrld[4];
   x_wrld[5] := x_wrld[3] - x_wrld[1] + x_wrld[4];   x_wrld[6] := x_temp + x_wrld[5];
   y_wrld[8] := y_temp + y_wrld[3];                  y_wrld[7] := y_temp + y_wrld[4];
   y_wrld[5] := y_wrld[3] - y_wrld[1] + y_wrld[4];   y_wrld[6] := y_temp + y_wrld[5];
   z_wrld[8] := z_temp + z_wrld[3];                  z_wrld[7] := z_temp + z_wrld[4];
   z_wrld[5] := z_wrld[3] - z_wrld[1] + z_wrld[4];   z_wrld[6] := z_temp + z_wrld[5];
   with  object  do
      begin
         lines_drawn := 0;
         line_count := 0;
         old_lines := lines;
         old_number_of_lines := number_of_lines;
         if  model = LARGE  then
            begin
               if  int(z_wrld[5] - z_wrld[4]) > 0  then
                  lines_drawn := lines_drawn or surface0
               else if  int(z_wrld[5] - z_wrld[4]) < 0  then
                  lines_drawn := lines_drawn or surface3;
               if  int(z_wrld[7] - z_wrld[4]) < 0  then
                  lines_drawn := lines_drawn or surface1
               else if  int(z_wrld[7] - z_wrld[4]) > 0  then
                  lines_drawn := lines_drawn or surface4;
               if  int(z_wrld[1] - z_wrld[4]) > 0  then
                  lines_drawn := lines_drawn or surface5
               else if  int(z_wrld[1] - z_wrld[4]) < 0  then
                  lines_drawn := lines_drawn or surface2;
            end
         else
            lines_drawn := lines_drawn or $2;
         for  j := 1 to 12  do
            begin
               line_mask := lines_drawn;
               if  (line_mask and line_loc[j]) > 0 then
                  begin
                     line_count := line_count + 1;
                     index := j * 2 - 1;
                     val(copy(lines_to_view,(index),1),first,dummy);
                     val(copy(lines_to_view,(index + 1),1),second,dummy);
                     Parallel_projection(line.x1,line.y1,x_wrld[first],y_wrld[first],z_wrld[first]);
                     Parallel_projection(line.x2,line.y2,x_wrld[second],y_wrld[second],z_wrld[second]);
                     lines[line_count] := line;
                     clipper(lines[line_count].x1,lines[line_count].y1,lines[line_count].x2,lines[line_count].y2);
                  end;
            end;
         number_of_lines := line_count;
      end;
end;  (* proc calculate_lines *)


Procedure draw_object(var object: object_info);

(* ================================================ *)
(* =  The Draw_Scrn procedure draw an  object on  = *)
(* =  the screen.                                 = *)
(* ================================================ *)

var
   i :  integer;

begin  (* proc Draw_Scrn *)
   with  object  do
      for  i := 1  to  number_of_lines  do
        with  lines[i]  do
          begin
            drawline(x1,y1,x2,y2,i);
          end;
end;  (* proc Draw_Scrn *)


Procedure erase_object(var object: object_info);

(* ================================================ *)
(* =  The Draw_Scrn procedure draw an  object on  = *)
(* =  the screen.                                 = *)
(* ================================================ *)

var
   i :  integer;

begin  (* proc Draw_Scrn *)
   with  object  do
      for  i := 1  to  old_number_of_lines  do
        with  old_lines[i]  do
          begin
            drawline(x1,y1,x2,y2,0);
          end;
end;  (* proc Draw_Scrn *)



procedure color_display(selection:cgtype);

(* ================================================ *)
(* =  The  selectmonitor  procedure  changes the  = *)
(* =  current monitor selection from  monochrome  = *)
(* =  to color graphics or vice-aversa.           = *)
(* ================================================ *)

var
   displayvar :  integer absolute $0000:$0410;

begin  (* proc colordsply *)
   if  selection = 'on'  then
      begin
         displayvar := (displayvar and 207) or 16;
         hires;
      end
   else if selection = 'off' then
      begin
         displayvar := displayvar or 48;
         textmode;
      end;
end;  (* proc colordsply *)


procedure SetEGAMode(mode : integer);

  type
    regset = record
               ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
             end;
  var
    registers : regset;

begin
  with registers do
    begin
      ax := mode;
      intr($10,registers);
    end;
END;


procedure EGA43;

begin
  inline($b8/$12/$11/         (* mov  ax,1112    *)
         $b3/$00/             (* mov  bl,00      *)
         $cd/$10/             (* int  10         *)
         $2b/$c0/             (* sub  ax,ax      *)
         $1e/                 (* push ds         *)
         $8e/$d8/             (* mov  ds,ax      *)
         $ff/$36/$87/$04/     (* push [0487]     *)
         $80/$0e/$87/$04/$01/ (* or   byte ptr [0487],01 *)
         $b9/$00/$06/         (* mov  cx,06      *)
         $b4/$01/             (* mov  ah,01      *)
         $cd/$10/             (* int  10         *)
         $8f/$06/$87/$04/     (* pop  [0487]     *)
         $1f);                 (* pop  ds         *)
       (*  $ba/$b4/$03/  *)       (* mov  dx,03b4    *)
       (*  $b8/$14/$07/  *)       (* mov  ax,0714    *)
       (*  $ef);         *)       (* out  dx,ax      *)
end;

begin (* main program *)
   dir := true;
   tx := 0;
   ty := 0;
   tz := 0;
   dist := 15.0;
   z_scale := longitudinal_scale;
   x_scale := horizontal_scale * (dist / 10);
   y_scale := vertical_scale * (dist / 10);
(*   hires; *)
(*   ega43; *)
   SetEGAMode(18);
   color := 32;

   theta := 1.0;
   phi   := 1.0;
   beta  := 1.0;
   Phi_change(trig_set,dir);
   Theta_change(trig_set,dir);
   beta_change(trig_set,dir);
   model := LARGE;
   get_object_from_file(test,'TEST');
   projection := PARALLEL;
   gwindow(250,20,380,199,DB);
   Phi_change(trig_set,dir);
   Theta_change(trig_set,dir);
   beta_change(trig_set,dir);
   calc_object_lines(test);
   draw_object(test);
   Writeln('┌───────┐');
   writeln('│ Start │');
   writeln('└───────┘');
   for  loop := 1  to  500  do
      begin
         Phi_change(trig_set,dir);
         Theta_change(trig_set,dir);
         beta_change(trig_set,dir);
         calc_object_lines(test);
         erase_object(test);
         draw_object(test);
      end;
   Writeln('┌──────┐');
   writeln('│ Done │');
   writeln('└──────┘');
   delay(3000);
   SetEGAMode(03);
end.  (* main program *)